home *** CD-ROM | disk | FTP | other *** search
Text File | 1992-08-23 | 10.4 KB | 317 lines | [TEXT/CCL2] |
- ;;;
- ;;; progress-indication.Lisp
- ;;;
-
- #|
- ================================================================
- Purpose ========================================================
- ================================================================
- Defines with-progress-indication and progress-step which provide a
- uniform way to note incremental progress during long operations. Fondly
- inspired by Symbolics' noting-progress mechanism.
-
- Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
- bugs, comments, questions, and fixes to cornell@cs.umass.edu.
-
-
- ================================================================
- Status =========================================================
- ================================================================
- Implemented but the progress dialog can be deselected, which needs to be
- fixed.
-
- Bug: Errors encountered during dolist-noting-progress cause a throw out of
- the loop WITH NO INDICATIONS that something went wrong!
-
-
- ================================================================
- Change history =================================================
- ================================================================
- 8-Jun-91 mc Created.
- 25-Jul-91 mc Added copyright and released.
- 18-Sep-91 mc Fixed view-draw-contents box-dialog-item to draw outline in
- container, not in the item itself.
- 14-Mar-92 mc Added (require "QUICKDRAW").
- 21-Mar-92 mc Changed view-draw-contents (box-dialog-item) to call
- #_FrameRect so that QUICKDRAW isn't required.
- Removed (require "QUICKDRAW").
- 22-Mar-92 mc Fixed view-draw-contents :after (progress-dialog-item) to call
- #_FillRect .
- Fixed view-draw-contents :after (progress-dialog-item) to not
- error when there are zero steps.
- 22-Apr-92 mc Added fixes by markt@dgp.toronto.EDU (marked by mt) . Thank you!
- 19-Jul-92 mc Bug: Calling progress-step with a numeric first arg and a null
- second arg does not update the gray status bar.
- mc Fixed above bug.
- 23-Jul-92 mc Changed box-dialog-item to progress-box-dialog-item to avoid
- name conflict with Apple's box-dialog-item defined in
- "scrollers.lisp"
- 23-Aug-92 mc Defined dolist-noting-progress macro.
- Added provide.
- Fixed with-progress-indication (wasn't returning values
- correctly).
-
- |#
-
-
- (in-package "CCL")
-
- (export '(WITH-PROGRESS-INDICATION
- PROGRESS-STEP
- DOLIST-NOTING-PROGRESS))
-
-
- #|
- (defun progress-step (step-num &optional step-text)
- "progress-step
- step-num &optional step-text
-
- Visually indicates step number STEP-NUM has taken place. STEP-TEXT, if
- passed, is drawn too. Use nil for STEP-NUM to update just STEP-TEXT and not
- the visual indicator."
- ;;
- )
- |#
-
-
- (defmacro with-progress-indication ((num-steps title) form)
- "with-progress-indication
- ((num-steps title) form)
-
- Executes FORM with a visual indication of percent done. NUM-STEPS is the
- total number of steps the task will take and is an integer. TITLE is a
- string used to label the entire task. During FORM's execution calls to
- progress-step can be made."
- ;;
- ;; Eval-time expansion.
- ;;
- (let ((dialog-var (gensym "dialog-"))
- (results-var (gensym "result-")))
- ;;
- ;; Run-time expansion.
- ;;
- `(let* ((,dialog-var (make-instance 'progress-dialog
- :num-steps ,num-steps :title ,title))
- ,results-var)
- (labels ((progress-step (step-num &optional step-text)
- (set-step ,dialog-var step-num step-text)))
- ;;
- (unwind-protect
- (progn (setf ,results-var (multiple-value-list ,form))
- (values-list ,results-var))
- (progn (window-close ,dialog-var)))))))
-
-
- ;;;
- ;;; The progress-box-dialog-item class.
- ;;;
-
- (defclass progress-box-dialog-item (dialog-item)
- ())
-
- (defmethod view-contains-point-p ((item progress-box-dialog-item)
- point)
- (declare (ignore point))
- ;;
- nil)
-
- (defmethod view-draw-contents ((item progress-box-dialog-item))
- "Draws a box around ITEM."
- ;;
- (let* ((topleft (view-position item))
- (bottomright (add-points topleft (view-size item)))
- (container (view-container item)))
- ;Following was (frame-rect container topleft bottomright) :
- (rlet ((p-rect :rect :topLeft topleft :bottomRight bottomright))
- (with-focused-view container
- (#_FrameRect p-rect)))))
-
-
- ;;;
- ;;; The progress-dialog-item class.
- ;;;
-
- (defclass progress-dialog-item (progress-box-dialog-item)
- ((num-steps
- :accessor progress-num-steps
- :initarg :progress-num-steps)
- (current-step
- :accessor progress-current-step
- :initform -1)
- )
- )
-
-
- (defmethod initialize-instance :after ((item progress-dialog-item)
- &key progress-num-steps)
- (unless progress-num-steps
- (error ":progress-num-steps initarg required.")))
-
-
- (defmethod view-draw-contents :after ((item progress-dialog-item))
- "Draws the percentage indicator based on progress-num-steps and
- progress-current-step."
- ;;
- ;; Draw only if progress-num-steps is non-zero (causes an error if
- ;; otherwise).
- ;;
- (when (and (numberp (progress-num-steps item))
- (plusp (progress-num-steps item)))
- (let* ((width (point-h (view-size item)))
- (height (point-v (view-size item)))
- (step-width (/ width (progress-num-steps item)))
- (right (round (* (1+ (progress-current-step item)) step-width))))
- ;Following was (fill-rect item *gray-pattern* 1 1 (1- right) (1- height)) :
- (rlet ((p-rect :rect :topLeft #@(1 1)
- :bottomRight (make-point (1- right) (1- height))))
- (with-focused-view item
- (#_FillRect p-rect *gray-pattern*))))))
-
-
- (defmethod set-step ((item progress-dialog-item)
- (step-num integer)
- &optional step-text)
- (declare (ignore step-text))
- ;;
- (when (>= step-num (progress-num-steps item))
- (error "step-num (~S) >= declared number of steps (~S)."
- step-num (progress-num-steps item)))
- ;;
- (setf (progress-current-step item) step-num)
- (with-focused-view item ; mt
- (view-draw-contents item) ; mt
- ))
-
-
- ;;;
- ;;; The progress-dialog class.
- ;;;
-
- (defclass progress-dialog (dialog)
- ()
- (:default-initargs
- :WINDOW-TYPE :DOUBLE-EDGE-BOX :VIEW-POSITION '(:TOP 60)
- :VIEW-SIZE #@(302 64) :CLOSE-BOX-P NIL
- :VIEW-FONT '("Chicago" 12 :SRCOR :PLAIN)))
-
-
- (defmethod initialize-instance :after ((dialog progress-dialog)
- &key num-steps title)
- (unless num-steps
- (error ":num-steps initarg required."))
- (unless title
- (error ":title initarg required."))
- ;;
- ;; Add the items, initialize 'title-text-item and 'progress-item.
- ;;
- (add-subviews dialog
- (MAKE-DIALOG-ITEM
- 'STATIC-TEXT-DIALOG-ITEM #@(3 1) #@(293 16)
- title NIL :VIEW-NICK-NAME 'title-text-item)
- (MAKE-DIALOG-ITEM
- 'STATIC-TEXT-DIALOG-ITEM #@(3 20) #@(293 22)
- "" NIL :VIEW-NICK-NAME 'step-text-item
- :view-font '("Helvetica" 9 :plain))
- (MAKE-DIALOG-ITEM
- 'progress-dialog-item #@(3 48) #@(296 12)
- "" NIL :VIEW-NICK-NAME 'progress-item
- :progress-num-steps num-steps))
- (view-draw-contents (view-named 'title-text-item dialog)))
-
-
- (defmethod set-step ((dialog progress-dialog) step-num &optional step-text)
- ;;
- (when step-text
- (with-focused-view dialog ; mt
- (when step-text
- (set-dialog-item-text (view-named 'step-text-item dialog) step-text))
- ;; Following was (view-draw-contents (view-named 'step-text-item dialog))
- (view-draw-contents dialog) ; mt
- ))
- (when step-num
- (set-step (view-named 'progress-item dialog) step-num)))
-
-
- ;;;================================================================
- ;;; Define the dolist-noting-progress macro
- ;;;================================================================
-
- (defmacro dolist-noting-progress ((var listform &optional resultform str-message)
- &body body)
- "Evaluates listform, which produces a list, and executes the body once
- for every element in the list. On each iteration, var is bound to
- successive elements of the list. Upon completion, resultform is
- evaluated, and the value is returned. If resultform is omitted, the
- result is nil. Str-message is a string that serves as the progress
- indication dialog's title. It defaults to 'Doing <listform result>…',
- where <listform result> is the result of evaluating listform, which is
- evaluated only once."
- ;;
- ;; Do eval-time bindings.
- ;;
- (let ((sym-list-var (gensym)))
- ;;
- ;; Return the run-time expansion.
- ;;
- `(let* ((,sym-list-var ,listform) ;stops multiple evaluations
- (int-length (length ,sym-list-var))
- (str-message (if (stringp ,str-message)
- ,str-message
- (format nil "Doing ~A…" ,sym-list-var)))
- ,var)
- (with-progress-indication (int-length str-message)
- (dotimes (int-index int-length ,resultform)
- (setf ,var (elt ,sym-list-var int-index))
- (progress-step int-index (format nil "~A" ,var))
- ,@body)))))
-
-
- ;;; Done.
-
- (provide "PROGRESS-INDICATION")
-
-
-
- #|
- ;;; Define some examples.
-
- (dolist-noting-progress (win (windows) (values-list '(1 2 3)) "Doing Windows…")
- (format t "~&Doing ~S now." win)
- (sleep 0.7))
-
-
- (defun run-demo ()
- ""
- ;;
- (let* ((windows (windows))
- (len (length windows)))
- (with-progress-indication (len "Windows Demo")
- (progn
- (progress-step nil "Setting up")
- (sleep .5)
- (dotimes (count len)
- (progress-step count (format nil "~A" (elt windows count)))
- (sleep 1))
- (progress-step nil "Cleaning up")
- (sleep .5)))))
-
-
- ;;; Note: when a GC occured during the show-bug button's action the
- ;;; progress window was grayed-out then the progress continued **but
- ;;; without an updated title**!
-
- (defun show-bug ()
- (MAKE-INSTANCE
- 'window
- :WINDOW-TYPE :DOCUMENT
- :VIEW-SIZE #@(129 97)
- :VIEW-SUBVIEWS (LIST
- (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
- #@(13 16)
- #@(88 18)
- "Show it"
- #'(lambda (item)
- (declare (ignore item))
- (run-demo))))))
-
- |#